Usenet 1993 July/InfoMagic USENET CD-ROM July 1993.ISO/sources/misc/volume26/tclx/part19

Text File | 1991-11-19 | 43.5 KB | 1,460 lines

Newsgroups: comp.sources.misc
From: [e-mail] (Karl Lehenbauer)
Subject:  v26i019:  tclx - extensions and on-line help for tcl 6.1, Part19/23
Message-ID: <[e-mail]>
X-Md4-Signature: 45fe6fdcb81989298d1a1319a2b0f430
Date: Tue, 19 Nov 1991 13:56:55 GMT
Approved: [e-mail]

Submitted-by: [e-mail] (Karl Lehenbauer)
Posting-number: Volume 26, Issue 19
Archive-name: tclx/part19
Environment: UNIX

#! /bin/sh
# This is a shell archive.  Remove anything before this line, then unpack
# it by saving it into a file and typing "sh file".  To overwrite existing
# files, type "sh file -c".  You can also feed this as standard input via
# unshar, or by typing "sh <file", e.g..  If this archive is complete, you
# will see the following message at the end:
#        "End of archive 19 (of 23)."
# Contents:  extended/src/list.c extended/src/signal.c
# Wrapped by karl@one on Wed Nov 13 21:50:31 1991
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'extended/src/list.c' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'extended/src/list.c'\"
else
echo shar: Extracting \"'extended/src/list.c'\" \(19858 characters\)
sed "s/^X//" >'extended/src/list.c' <<'END_OF_FILE'
X/*
X * list.c --
X *
X *      TCL extend list commands.
X *---------------------------------------------------------------------------
X * Copyright 1991 Karl Lehenbauer and Mark Diekhans.
X *
X * Permission to use, copy, modify, and distribute this software and its
X * documentation for any purpose and without fee is hereby granted, provided
X * that the above copyright notice appear in all copies.  Karl Lehenbauer and
X * Mark Diekhans make no representations about the suitability of this
X * software for any purpose.  It is provided "as is" without express or
X * implied warranty.
X */
X
X#include "tclExtdInt.h"
X
X/*
X * Prototypes of internal functions.
X */
Xint
XCompareKeyListField _ANSI_ARGS_((Tcl_Interp   *interp,
X                                 char         *fieldName,
X                                 char         *field,
X                                 char        **valuePtr,
X                                 int          *valueSizePtr));
X
Xint
XFindKeyListField _ANSI_ARGS_((Tcl_Interp  *interp,
X                              char        *fieldName,
X                              int          listArgc,
X                              char       **listArgv,
X                              int         *listIdxPtr));
X
Xint
XTcl_GetKeyedListField _ANSI_ARGS_((Tcl_Interp  *interp,
X                                   CONST char  *fieldName,
X                                   CONST char  *keyedList,
X                                   char       **fieldValuePtr));
X
Xchar *
XTcl_SetKeyedListField _ANSI_ARGS_((Tcl_Interp  *interp,
X                                   CONST char  *fieldName,
X                                   CONST char  *fieldvalue,
X                                   CONST char  *keyedList));
X
Xchar *
XTcl_DeleteKeyedListField _ANSI_ARGS_((Tcl_Interp  *interp,
X                                      CONST char  *fieldName,
X                                      CONST char  *keyedList));
X
X/*
X *----------------------------------------------------------------------
X *
X * CompareKeyListField --
X *   Compare a field name to a field (keyword/value pair) to determine if
X * the field names match.
X *
X * Parameters:
X *   o interp (I/O) - Error message will be return in result if there is an
X *     error.
X *   o fieldName (I) - Field name to compare against field.
X *   o field (I) - Field to see if its name matches.
X *   o valuePtr (O) - If the field names match, a pointer to value part is
X *     returned.
X *   o valueSizePtr (O) - If the field names match, the length of the value
X *     part is returned here.
X * Results:
X *    TCL_OK - If the field names match.
X *    TCL_BREAK - If the fields names don't match.
X *    TCL_ERROR -  If the list has an invalid format.
X *----------------------------------------------------------------------
X */
Xstatic int
XCompareKeyListField (interp, fieldName, field, valuePtr, valueSizePtr)
X    Tcl_Interp   *interp;
X    char         *fieldName;
X    char         *field;
X    char        **valuePtr;
X    int          *valueSizePtr;
X{
X    char *elementPtr, *nextPtr;
X    int   fieldNameSize, elementSize;
X
X    if (field [0] == '\0') {
X        Tcl_AppendResult (interp, "invalid keyed list format: ",
X                          "list contains an empty field entry",
X                          (char *) NULL);
X        return TCL_ERROR;
X    }
X    if (TclFindElement (interp, field, &elementPtr, &nextPtr,
X                        &elementSize, NULL) != TCL_OK)
X        return TCL_ERROR;
X    if (elementSize == 0) {
X        Tcl_AppendResult (interp, "invalid keyed list format: ",
X                          "list contains an empty field name",
X                          (char *) NULL);
X        return TCL_ERROR;
X    }
X    if (nextPtr[0] == '\0') {
X        Tcl_AppendResult (interp, "invalid keyed list format: ",
X                          "no value associated with field \"",
X                          elementPtr, "\"", (char *) NULL);
X        return TCL_ERROR;
X    }
X
X    fieldNameSize = strlen (fieldName);
X    if (!((elementSize == fieldNameSize) &&
X            STRNEQU (elementPtr, fieldName, fieldNameSize)))
X        return TCL_BREAK;   /* Names do not match */
X
X    /*
X     * Extract the value from the list.
X     */
X    if (TclFindElement (interp, nextPtr, &elementPtr, &nextPtr, &elementSize,
X                        NULL) != TCL_OK)
X        return TCL_ERROR;
X    if (nextPtr[0] != '\0') {
X        Tcl_AppendResult (interp, "invalid keyed list format: ",
X                          "trailing data following value in field: \"",
X                          elementPtr, "\"", (char *) NULL);
X        return TCL_ERROR;
X    }
X    *valuePtr = elementPtr;
X    *valueSizePtr = elementSize;
X    return TCL_OK;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * FindKeyListField --
X *   Locate a field (key/value pair) in a key list that has been broken
X * into an argv.
X *
X * Parameters:
X *   o interp (I/O) - Error message will be return in result if there is an
X *     error.
X *   o fieldName (I) - The name of the field to find, should have all
X *     subsequent parts (seperated by `.'), the pointer to the next part will
X *     be returned as part of the parseResult.
X *   o listArgc/listArgv (I) - The keyed list, split into an argv.
X *   o listIdxPtr (O) - The argv index containing the list entry that matches
X *     the field name, or -1 if the key was not found.
X * Results:
X *   Standard Tcl result.
X *----------------------------------------------------------------------
X */
Xstatic int
XFindKeyListField (interp, fieldName, listArgc, listArgv, listIdxPtr)
X    Tcl_Interp  *interp;
X    char        *fieldName;
X    int          listArgc;
X    char       **listArgv;
X    int         *listIdxPtr;
X{
X    int   idx, result, valueSize;
X    char *value;
X
X    for (idx = 0; idx < listArgc; idx++) {
X        result = CompareKeyListField (interp, fieldName, listArgv [idx],
X                                      &value, &valueSize);
X        if (result != TCL_BREAK)
X            break;  /* Found or error */
X    }
X    if (result == TCL_ERROR)
X        return TCL_ERROR;
X    if (idx >= listArgc)
X        *listIdxPtr = -1;  /* Not found */
X    else
X        *listIdxPtr = idx;
X    return TCL_OK;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_GetKeyedListField --
X *   Retrieve a field value from a keyed list.  The list is walked rather than
X * converted to a argv for increased performance.
X *
X * Parameters:
X *   o interp (I/O) - Error message will be return in result if there is an
X *     error.
X *   o fieldName (I) - The name of the field to extract.
X *   o keyedList (I) - The list to search for the field.
X *   o fieldValuePtr (O) - If the field is found, a pointer to a dynamicly
X *     allocated string containing the value is returned here.  If NULL is
X *     specified, then only the presence of the field is validated, the
X *     value is not returned.
X * Results:
X *   TCL_OK - If the field was found.
X *   TCL_BREAK - If the field was not found.
X *   TCL_ERROR - If an error occured.
X *----------------------------------------------------------------------
X */
Xint
XTcl_GetKeyedListField (interp, fieldName, keyedList, fieldValuePtr)
X    Tcl_Interp  *interp;
X    CONST char  *fieldName;
X    CONST char  *keyedList;
X    char       **fieldValuePtr;
X{
X    char *scanPtr;
X    char *value;
X    int   valueSize, result;
X
X    /*
X     * Walk the list looking for a field name that matches.
X     */
X    scanPtr = (char *) keyedList;
X    result = TCL_OK;
X    while (*scanPtr != '\0') {
X        char *fieldPtr;
X        int   fieldSize;
X        char  saveChar;
X
X        result = TclFindElement (interp, scanPtr, &fieldPtr, &scanPtr,
X                                 &fieldSize, NULL);
X        if (result != TCL_OK)
X            break;
X
X        saveChar = fieldPtr [fieldSize];
X        fieldPtr [fieldSize] = '\0';
X
X        result = CompareKeyListField (interp, (char *) fieldName, fieldPtr,
X                                      &value, &valueSize);
X        fieldPtr [fieldSize] = saveChar;
X        if (result != TCL_BREAK)
X            break;  /* Found or an error */
X    }
X
X    if (result != TCL_OK)
X        return result;   /* Not found or an error */
X
X    if (fieldValuePtr != NULL) {
X        char *fieldValue;
X
X        fieldValue = ckalloc (valueSize + 1);
X        strncpy (fieldValue, value, valueSize);
X        fieldValue [valueSize] = '\0';
X        *fieldValuePtr = fieldValue;
X    }
X    return TCL_OK;  /* Found! */
X
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_SetKeyedListField --
X *   Set a field value in keyed list.
X *
X * Parameters:
X *   o interp (I/O) - Error message will be return in result if there is an
X *     error.
X *   o fieldName (I) - The name of the field to set.
X *   o fieldValue (I) - The value to set for the field.
X *   o keyedList (I) - The keyed list to set a field value in, may be an
X *     NULL or an empty list to create a new keyed list.
X * Results:
X *   A pointer to a dynamically allocated string, or NULL if an error
X *   occured.
X *----------------------------------------------------------------------
X */
Xchar *
XTcl_SetKeyedListField (interp, fieldName, fieldValue, keyedList)
X    Tcl_Interp  *interp;
X    CONST char  *fieldName;
X    CONST char  *fieldValue;
X    CONST char  *keyedList;
X{
X    char   *newField, *newList;
X    int     listArgc, fieldIdx;
X    char  **listArgv = NULL;
X    char   *newArgv [2];
X
X    if (fieldName == '\0') {
X        Tcl_AppendResult (interp, "null key not allowed", (char *) NULL);
X        return NULL;
X    }
X
X    /*
X     * Build a list out of the new key/value pair, we may need it soon.
X     */
X    newArgv [0] = (char *) fieldName;
X    newArgv [1] = (char *) fieldValue;
X    newField = Tcl_Merge (2, newArgv);
X
X    if (keyedList == NULL)
X        keyedList = "";
X
X    /*
X     * Parse the keyed list into an argv and search for the key/value pair.
X     */
X    if (Tcl_SplitList (interp, (char *) keyedList, &listArgc,
X                       &listArgv) != TCL_OK)
X        goto errorExit;
X
X    if (FindKeyListField (interp, (char *) fieldName, listArgc, listArgv,
X                          &fieldIdx) != TCL_OK)
X        goto errorExit;
X
X    /*
X     * If the field does not current exist in the keyed list, append it,
X     * otherwise replace it.
X     */
X    if (fieldIdx == -1) {
X        fieldIdx = listArgc;
X        listArgc++;
X    }
X
X    listArgv [fieldIdx] = newField;
X    newList = Tcl_Merge (listArgc, listArgv);
X
X    ckfree ((char *) newField);
X    ckfree ((char *) listArgv);
X    return newList;
X
XerrorExit:
X    ckfree ((char *) newField);
X    if (listArgv != NULL)
X        ckfree ((char *) listArgv);
X    return NULL;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_DeleteKeyedListField --
X *   Delete a field value in keyed list.
X *
X * Parameters:
X *   o interp (I/O) - Error message will be return in result if there is an
X *     error.
X *   o fieldName (I) - The name of the field to set.
X *   o fieldValue (I) - The value to set for the field.
X *   o keyedList (I) - The keyed list to set a field value in, may be an
X *     NULL or an empty list to create a new keyed list.
X * Results:
X *   A pointer to a dynamically allocated string, or NULL if an error
X *   occured.
X *----------------------------------------------------------------------
X */
Xchar *
XTcl_DeleteKeyedListField (interp, fieldName, keyedList)
X    Tcl_Interp  *interp;
X    CONST char  *fieldName;
X    CONST char  *keyedList;
X{
X    char  *newList;
X    int    listArgc, fieldIdx, idx;
X    char **listArgv;
X
X    if (fieldName == '\0') {
X        Tcl_AppendResult (interp, "null key not allowed", (char *) NULL);
X        return NULL;
X    }
X
X    if (Tcl_SplitList (interp, (char *) keyedList, &listArgc,
X                       &listArgv) != TCL_OK)
X        return NULL;
X
X    if (FindKeyListField (interp, (char *) fieldName, listArgc, listArgv,
X                          &fieldIdx) != TCL_OK)
X        goto errorExit;
X
X    if (fieldIdx == -1) {
X        Tcl_AppendResult (interp, "field name not found: \"",  fieldName,
X                          "\"", (char *) NULL);
X        goto errorExit;
X    }
X
X    /*
X     * Move all entries in the argv following the one being deleted, up one
X     * spot.
X     */
X    for (idx = fieldIdx; idx < listArgc; idx++)
X        listArgv [idx] = listArgv [idx + 1];
X
X    newList = Tcl_Merge (listArgc - 1, listArgv);
X
X    ckfree ((char *) listArgv);
X    return newList;
X
XerrorExit:
X    ckfree ((char *) listArgv);
X    return NULL;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_KeyldelCmd --
X *     Implements the TCL keyldel command:
X *         keyldel listvar key
X *
X * Results:
X *    Standard TCL results.
X *
X *----------------------------------------------------------------------
X */
Xint
XTcl_KeyldelCmd (clientData, interp, argc, argv)
X    ClientData  clientData;
X    Tcl_Interp *interp;
X    int         argc;
X    char      **argv;
X{
X    char  *keyedList, *newList;
X    int    listArgc, fieldIdx, idx;
X    char **listArgv;
X    char  *varPtr;
X
X    if (argc != 3) {
X        Tcl_AppendResult (interp, "wrong # args: ", argv [0],
X                          " listvar key", (char *) NULL);
X        return TCL_ERROR;
X    }
X
X    keyedList = Tcl_GetVar (interp, argv[1], TCL_LEAVE_ERR_MSG);
X    if (keyedList == NULL)
X        return TCL_ERROR;
X
X    newList = Tcl_DeleteKeyedListField (interp, argv [2], keyedList);
X    if (newList == NULL)
X        return TCL_ERROR;
X
X    varPtr = Tcl_SetVar (interp, argv [1], newList, TCL_LEAVE_ERR_MSG);
X    ckfree ((char *) newList);
X
X    return (varPtr == NULL) ? TCL_ERROR : TCL_OK;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_KeylgetCmd --
X *     Implements the TCL keylget command:
X *         keylget listvar key [retvar | {}]
X *
X * Results:
X *    Standard TCL results.
X *
X *----------------------------------------------------------------------
X */
Xint
XTcl_KeylgetCmd (clientData, interp, argc, argv)
X    ClientData  clientData;
X    Tcl_Interp *interp;
X    int         argc;
X    char      **argv;
X{
X    char   *keyedList;
X    char   *fieldValue;
X    char  **fieldValuePtr;
X    int     result;
X
X    if ((argc < 3) || (argc > 4)) {
X        Tcl_AppendResult (interp, "wrong # args: ", argv [0],
X                          " listvar key [retvar | {}]", (char *) NULL);
X        return TCL_ERROR;
X    }
X    if (argv [2] == '\0') {
X        Tcl_AppendResult (interp, "null key not allowed", (char *) NULL);
X        return TCL_ERROR;
X    }
X    keyedList = Tcl_GetVar (interp, argv[1], TCL_LEAVE_ERR_MSG);
X    if (keyedList == NULL)
X        return TCL_ERROR;
X
X    /*
X     * Recursively extract the field (or sub-field) value.  First determine
X     * if we actually need a value.
X     */
X    if ((argc == 4) && (argv [3][0] == '\0'))
X        fieldValuePtr = NULL;
X    else
X        fieldValuePtr = &fieldValue;
X
X    result = Tcl_GetKeyedListField (interp, argv [2], keyedList,
X                                    fieldValuePtr);
X    if (result == TCL_ERROR)
X        return TCL_ERROR;
X
X    /*
X     * Handle field name not found.
X     */
X    if (result == TCL_BREAK) {
X        if (argc == 3) {
X            Tcl_AppendResult (interp, "key \"", argv [2],
X                              "\" not found in keyed list", (char *) NULL);
X            return TCL_ERROR;
X        } else {
X            interp->result = "0";
X            return TCL_OK;
X        }
X    }
X
X    /*
X     * Handle field name found and return in the result.
X     */
X    if (argc == 3) {
X        Tcl_SetResult (interp, fieldValue, TCL_DYNAMIC);
X        return TCL_OK;
X    }
X
X    /*
X     * Handle null return variable specified and key was found.
X     */
X    if (argv [3][0] == '\0') {
X        interp->result = "1";
X        return TCL_OK;
X    }
X
X    /*
X     * Handle returning the value to the variable.
X     */
X    if (Tcl_SetVar (interp, argv [3], fieldValue, TCL_LEAVE_ERR_MSG) == NULL)
X        result = TCL_ERROR;
X    else
X        result = TCL_OK;
X    ckfree (fieldValue);
X    interp->result = "1";
X    return result;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_KeylsetCmd --
X *     Implements the TCL keylset command:
X *         keylset listvar key value
X *
X * Results:
X *    Standard TCL results.
X *
X *----------------------------------------------------------------------
X */
Xint
XTcl_KeylsetCmd (clientData, interp, argc, argv)
X    ClientData  clientData;
X    Tcl_Interp *interp;
X    int         argc;
X    char      **argv;
X{
X    char *keyedList, *newList;
X    char *varPtr;
X
X    if (argc != 4) {
X        Tcl_AppendResult (interp, "wrong # args: ", argv [0],
X                          " listvar key value", (char *) NULL);
X        return TCL_ERROR;
X    }
X
X    keyedList = Tcl_GetVar (interp, argv[1], 0);
X
X    newList = Tcl_SetKeyedListField (interp, argv [2], argv [3], keyedList);
X    if (newList == NULL)
X        return TCL_ERROR;
X
X    varPtr = Tcl_SetVar (interp, argv [1], newList, TCL_LEAVE_ERR_MSG);
X    ckfree ((char *) newList);
X
X    return (varPtr == NULL) ? TCL_ERROR : TCL_OK;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_LvarpopCmd --
X *     Implements the TCL replace command:
X *         lvarpop var [index [string]]
X *
X * Results:
X *      Standard TCL results.
X *
X *----------------------------------------------------------------------
X */
Xint
XTcl_LvarpopCmd (clientData, interp, argc, argv)
X    ClientData  clientData;
X    Tcl_Interp *interp;
X    int         argc;
X    char      **argv;
X{
X    int        myargc, result;
X    char     **myargv;
X    char      *varcontents;
X    unsigned   listIdx, idx;
X    char      *resultList;
X
X    if ((argc < 2) || (argc > 4)) {
X        Tcl_AppendResult (interp, "wrong # args: ", argv [0],
X                          " var [index [string]]", (char *) NULL);
X        return TCL_ERROR;
X    }
X
X    varcontents = Tcl_GetVar (interp, argv[1], TCL_LEAVE_ERR_MSG);
X    if (varcontents == NULL)
X        return TCL_ERROR;
X
X    if (Tcl_SplitList (interp, varcontents, &myargc, &myargv) == TCL_ERROR) {
X        result = TCL_ERROR;
X        goto exitPoint;
X    }
X    if (argc == 2)
X        listIdx = 0;
X    else
X        if (Tcl_GetUnsigned (interp, argv[2], &listIdx) != TCL_OK) {
X            result = TCL_ERROR;
X            goto exitPoint;
X        }
X
X    /*
X     * This is dangerous, but this is like the standard Tcl commands.
X     */
X    if (listIdx >= myargc) {
X        result = TCL_OK;
X        goto exitPoint;
X    }
X    Tcl_SetResult (interp, myargv[listIdx], TCL_VOLATILE);
X
X    if (argc == 4)
X        myargv [listIdx] = argv[3];
X    else {
X        myargc--;
X        for (idx = listIdx; idx < myargc; idx++)
X            myargv [idx] = myargv[idx+1];
X    }
X
X    resultList = Tcl_Merge(myargc, myargv);
X    if (Tcl_SetVar (interp, argv[1], resultList, TCL_LEAVE_ERR_MSG) == NULL)
X        result = TCL_ERROR;
X    else
X        result = TCL_OK;
X    ckfree (resultList);
X
XexitPoint:
X    ckfree((char *) myargv);
X    return result;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_LemptyCmd --
X *     Implements the strcat TCL command:
X *         lempty list
X *
X * Results:
X *     Standard TCL result.
X *
X *----------------------------------------------------------------------
X */
Xint
XTcl_LemptyCmd (clientData, interp, argc, argv)
X    ClientData   clientData;
X    Tcl_Interp  *interp;
X    int          argc;
X    char       **argv;
X{
X    char *scanPtr;
X
X    if (argc != 2) {
X        Tcl_AppendResult (interp, "wrong # args: ", argv [0], " list",
X                          (char *) NULL);
X        return TCL_ERROR;
X    }
X
X    scanPtr = argv [1];
X    while ((*scanPtr != '\0') && (isspace (*scanPtr)))
X        scanPtr++;
X    sprintf (interp->result, "%d", (*scanPtr == '\0'));
X    return TCL_OK;
X
X} /* Tcl_LemptyCmd */
END_OF_FILE
if test 19858 -ne `wc -c <'extended/src/list.c'`; then
    echo shar: \"'extended/src/list.c'\" unpacked with wrong size!
fi
# end of 'extended/src/list.c'
fi
if test -f 'extended/src/signal.c' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'extended/src/signal.c'\"
else
echo shar: Extracting \"'extended/src/signal.c'\" \(20540 characters\)
sed "s/^X//" >'extended/src/signal.c' <<'END_OF_FILE'
X/*
X * signal.c --
X *
X * Tcl Unix signal support routines and the signal and trap commands.
X *---------------------------------------------------------------------------
X * Copyright 1991 Karl Lehenbauer and Mark Diekhans.
X *
X * Permission to use, copy, modify, and distribute this software and its
X * documentation for any purpose and without fee is hereby granted, provided
X * that the above copyright notice appear in all copies.  Karl Lehenbauer and
X * Mark Diekhans make no representations about the suitability of this
X * software for any purpose.  It is provided "as is" without express or
X * implied warranty.
X */
X
X#include "tclExtdInt.h"
X
X
X#ifndef SIGCLD
X#   define SIGCLD SIGCHLD
X#endif
X#ifndef SIGCHLD
X#   define SIGCHLD SIGCLD
X#endif
X
X#ifndef MAXSIG
X#    define MAXSIG 32
X#endif
X
X/*
X * Signal name table maps name to number.
X */
X
X#define SIG_NAME_MAX 7
X
Xstatic struct {char *name;
X        short num;
X       } sigNameTable [] = {
X    "HUP",     SIGHUP,
X    "INT",     SIGINT,
X    "QUIT",    SIGQUIT,
X    "ILL",     SIGILL,
X    "TRAP",    SIGTRAP,
X    "IOT",     SIGIOT,
X#ifdef SIGABRT
X    "ABRT",    SIGABRT,
X#endif
X    "EMT",     SIGEMT,
X    "FPE",     SIGFPE,
X    "KILL",    SIGKILL,
X    "BUS",     SIGBUS,
X    "SEGV",    SIGSEGV,
X    "SYS",     SIGSYS,
X    "PIPE",    SIGPIPE,
X    "ALRM",    SIGALRM,
X    "TERM",    SIGTERM,
X    "USR1",    SIGUSR1,
X    "USR2",    SIGUSR2,
X    "CLD",     SIGCLD,
X    "CHLD",    SIGCHLD,
X#ifdef SIGPWR
X    "PWR",     SIGPWR,
X#endif
X#ifdef SIGPOLL
X    "POLL",    SIGPOLL,
X#endif
X#ifdef SIGSTOP
X    "STOP",    SIGSTOP,
X#endif
X#ifdef SIGTSTP
X    "TSTP",    SIGTSTP,
X#endif
X#ifdef SIGCONT
X    "CONT",    SIGCONT,
X#endif
X#ifdef SIGTTIN
X    "TTIN",    SIGTTIN,
X#endif
X#ifdef SIGTTOU
X    "TTOU",    SIGTTOU,
X#endif
X    NULL,         -1};
X
X#ifdef TCL_SIG_PROC_INT
X#   define SIG_PROC_TYPE int
X#else
X#   define SIG_PROC_TYPE void
X#endif
X
X/*
X * Globals that indicate if we got a signal and which ones we got.
X */
Xstatic int           recievedSignal = FALSE;
Xstatic unsigned char signalsRecieved [MAXSIG];
X
X/*
X * Table of commands to evaluate when a signal occurs.  If the command is
X * NULL and the signal is recieved, an error is returned.
X */
Xstatic char *signalTrapCmds [MAXSIG];
X
X/*
X * Prototypes of internal functions.
X */
X
XSIG_PROC_TYPE (*
XGetSignalState _ANSI_ARGS_((int signalNum)));
X
Xint
XSetSignalAction _ANSI_ARGS_((int             signalNum,
X                             SIG_PROC_TYPE (*sigFunc)()));
X
Xstatic SIG_PROC_TYPE
XTclSignalTrap _ANSI_ARGS_((int signalNum));
X
Xstatic int
XEvalTrapCode _ANSI_ARGS_((Tcl_Interp *interp,
X                          int         signalNum,
X                          char       *command));
X
Xstatic int
XParseSignalList _ANSI_ARGS_((Tcl_Interp *interp,
X                             char       *signalListStr,
X                             int         signalList []));
X
Xstatic void
XSignalCmdCleanUp _ANSI_ARGS_((ClientData clientData));
X
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_SigNameToNum --
X *     Converts a UNIX signal name to its number, returns -1 if not found.
X *     the name may be upper or lower case and may optionally have the
X *     leading "SIG" omitted.
X *
X *----------------------------------------------------------------------
X */
Xint
XTcl_SigNameToNum (sigName)
X    char *sigName;
X{
X    char  sigNameUp [SIG_NAME_MAX+1];  /* Upshifted signal name */
X    char *sigNamePtr;
X    int   idx;
X
X    /*
X     * Copy and upshift requested name.
X     */
X
X    if (strlen (sigName) > SIG_NAME_MAX)
X        return -1;   /* Name too long */
X
X    Tcl_UpShift (sigNameUp, sigName);
X
X    if (STRNEQU (sigNameUp, "SIG", 3))
X        sigNamePtr = &sigNameUp [3];
X    else
X        sigNamePtr = sigNameUp;
X
X    for (idx = 0; sigNameTable [idx].num != -1; idx++)
X        if (STREQU (sigNamePtr, sigNameTable [idx].name))
X            break;
X
X    return sigNameTable [idx].num;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * GetSignalState --
X *     Get the current state of the specified signal.
X * Parameters:
X *   o signalNum (I) - Signal number to query.
X * Results
X *   The signal function or SIG_DFL or SIG_IGN.  If an error occures,
X *   SIG_ERR is returned (check errno);
X *----------------------------------------------------------------------
X */
Xstatic SIG_PROC_TYPE (*
XGetSignalState (signalNum))
X    int signalNum;
X{
X#ifdef TCL_POSIX_SIG
X    struct sigaction currentState;
X
X    if (sigaction (signalNum, NULL, ¤tState) < 0)
X        return SIG_ERR;
X    return currentState.sa_handler;
X#else
X    SIG_PROC_TYPE  (*actionFunc)();
X
X    if (signalNum == SIGKILL)
X        return SIG_DFL;
X
X    actionFunc = signal (signalNum, SIG_DFL);
X    if (actionFunc == SIG_ERR)
X        return SIG_ERR;
X    if (actionFunc != SIG_DFL)
X        signal (signalNum, actionFunc);  /* reset */
X    return actionFunc;
X#endif
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * SetSignalAction --
X *     Set the action to occur when a signal is received.
X * Parameters:
X *   o signalNum (I) - Signal number to query.
X *   o sigFunc (O) - The signal function or SIG_DFL or SIG_IGN.
X * Results
X *   TRUE if ok,  FALSE if an error (check errno).
X *----------------------------------------------------------------------
X */
Xstatic int
XSetSignalAction (signalNum, sigFunc)
X    int             signalNum;
X    SIG_PROC_TYPE (*sigFunc)();
X{
X#ifdef TCL_POSIX_SIG
X    struct sigaction newState;
X    sigset_t         sigUnblockSet;
X
X    newState.sa_handler = sigFunc;
X    sigfillset (&newState.sa_mask);
X    newState.sa_flags = 0;
X
X    if (sigaction (signalNum, &newState, NULL) < 0)
X        return FALSE;
X
X    sigemptyset (&sigUnblockSet);
X    sigaddset (&sigUnblockSet, signalNum);
X    if (sigprocmask (SIG_UNBLOCK, &sigUnblockSet, NULL) < 0)
X        return FALSE;
X    return TRUE;
X#else
X    if (signal (signalNum, sigFunc) == SIG_ERR)
X        return FALSE;
X    else
X        return TRUE;
X#endif
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * TclSignalTrap --
X *     Trap handler for UNIX signals.  Sets a flag indicating that the
X *     trap has occured, saves the name and rearms the trap.  The flag
X *     will be seen by the interpreter when its safe to trap.
X * Globals:
X *   o recievedSignal (O) - Set to TRUE, to indicate a signal was recieved.
X *   o signalsRecieved (O) - The entry indicating which signal we recieved
X *     will be set to TRUE;
X *----------------------------------------------------------------------
X */
Xstatic SIG_PROC_TYPE
XTclSignalTrap (signalNum)
X    int signalNum;
X{
X    signalsRecieved [signalNum] = TRUE;
X    recievedSignal = TRUE;
X#ifdef TCL_POSIX_SIG
X    if (signalNum != SIGCHLD) {
X        sigset_t sigBlockSet;
X
X        sigemptyset (&sigBlockSet);
X        sigaddset (&sigBlockSet, SIGCHLD);
X        if (sigprocmask (SIG_BLOCK, &sigBlockSet, NULL) < 0)
X            panic ("TclSignalTrap bug");
X    }
X#else
X    if (signalNum != SIGCHLD) {
X        if (SetSignalAction (signalNum, TclSignalTrap) < 0)
X            panic ("TclSignalTrap bug");
X    }
X#endif
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * EvalTrapCode --
X *     Run code as the result of a signal.  The code will be run in the
X *     global context, with the symbolic signal name in a global variable.
X *     signalReceived.  If an error occured, then the result will be
X *     left in the interp, if no error occured, the result will be reset.
X * Parameters:
X *   o interp (I/O) - The interpreter to run the signal in.
X *   o signalNum (I) - The signal number of the signal that occured.
X *   o command (I) - The command string to execute.
X * Return:
X *   TCL_OK or TCL_ERROR.
X *----------------------------------------------------------------------
X */
Xstatic int
XEvalTrapCode (interp, signalNum, command)
X    Tcl_Interp *interp;
X    int         signalNum;
X    char       *command;
X{
X    Interp        *iPtr = (Interp *) interp;
X    char          *signalName;
X    int            result;
X    CallFrame     *savedVarFramePtr;
X
X    Tcl_ResetResult (interp);
X
X    /*
X     * Modify the interpreter state to execute in the global frame.
X     */
X    savedVarFramePtr = iPtr->varFramePtr;
X    iPtr->varFramePtr = NULL;
X
X    /*
X     * Force name to always be SIGCHLD, even if system defines only SIGCLD.
X     */
X    if (signalNum == SIGCHLD)
X        signalName = "SIGCHLD";
X    else
X        signalName = Tcl_SignalId (signalNum);
X
X    if (Tcl_SetVar (interp, "signalRecieved", signalName,
X                    TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG) == NULL)
X        result = TCL_ERROR;
X    else
X        result = TCL_OK;
X    if (result == TCL_OK);
X        result = Tcl_Eval (interp, signalTrapCmds [signalNum], 0, NULL);
X
X    /*
X     * Restore the frame pointer and return the result (only OK or ERROR).
X     */
X    iPtr->varFramePtr = savedVarFramePtr;
X
X    if (result == TCL_ERROR) {
X        char errorInfo [TCL_RESULT_SIZE];
X
X        sprintf (errorInfo, "\n    while executing signal trap code for %s%s",
X                 signalName, " signal");
X        Tcl_AddErrorInfo (interp, errorInfo);
X
X        return TCL_ERROR;
X    } else {
X        Tcl_ResetResult (interp);
X        return TCL_OK;
X    }
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_ResetSignals --
X *
X *   Reset all of the signal flags to indicate that no signals have
X * occured.  This is used by the shell at the beginning of each interactive
X * command
X *
X * Globals:
X *   o recievedSignal (O) - Will be cleared.
X *   o signalsRecieved (O) - The indicates which signal where recieved.
X *----------------------------------------------------------------------
X */
Xvoid
XTcl_ResetSignals ()
X{
X    int  signalNum;
X
X    recievedSignal = FALSE;
X    for (signalNum = 0; signalNum < MAXSIG; signalNum++)
X        signalsRecieved [signalNum] = FALSE;
X
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_CheckForSignal --
X *
X *   Called by Tcl_Eval to check if a signal was received when Tcl_Eval is in
X * a safe state.  If the signal was received, this handles processing the
X * signal prehaps recursively eval-ing some code.  This is called just after a
X * command completes.  The results of the command are passed to this procedure
X * and may be altered by it.  If trap code is specified for the signal that
X * was recieved, then the trap will be executed, otherwise an error result
X * will be returned indicating that the signal occured.
X *
X * Parameters:
X *   o interp (I/O) - Interp->result should contain the result for
X *     the command that just executed.  This will either be restored or
X *     replaced with a new result.
X *   o cmdResultCode (I) - The integer result returned by the command that
X *     Tcl_Eval just completed.
X * Globals:
X *   o recievedSignal (O) - Will be cleared.
X *   o signalsRecieved (O) - The indicates which signal where recieved.
X * Returns:
X *   Either the original result core, an error result if one of the
X *   trap commands returned an error, or an error indicating the
X *   a signal occured.
X *----------------------------------------------------------------------
X */
Xint
XTcl_CheckForSignal (interp, cmdResultCode)
X    Tcl_Interp *interp;
X    int         cmdResultCode;
X{
X    char   *savedResult;
X    int     signalNum, result, retErrorForSignal = -1;
X
X    if (!recievedSignal)
X        return cmdResultCode;  /* Not signal recieved */
X
X    savedResult = ckalloc (strlen (interp->result) + 1);
X    strcpy (savedResult, interp->result);
X    Tcl_ResetResult (interp);
X
X    for (signalNum = 1; signalNum < MAXSIG; signalNum++) {
X        if (signalsRecieved [signalNum]) {
X            signalsRecieved [signalNum] = FALSE;
X            if (signalTrapCmds [signalNum] == NULL)
X                retErrorForSignal = signalNum;
X            else {
X                result = EvalTrapCode (interp, signalNum,
X                                       signalTrapCmds [signalNum]);
X                if (result == TCL_ERROR)
X                    goto exitPoint;
X            }
X        }
X    }
X
X    if (retErrorForSignal >= 0) {
X        char *signalName;
X
X        /*
X         * Force name to always be SIGCHLD, even if system defines only SIGCLD.
X         */
X        if (retErrorForSignal == SIGCHLD)
X            signalName = "SIGCHLD";
X        else
X            signalName = Tcl_SignalId (retErrorForSignal);
X
X        Tcl_SetErrorCode (interp, "UNIX SIG ", signalName, (char*) NULL);
X        Tcl_AppendResult (interp, signalName, " signal received",
X                          (char *)NULL);
X        result = TCL_ERROR;
X    } else {
X        Tcl_SetResult (interp, savedResult, TCL_DYNAMIC);
X        savedResult = NULL;
X        result = cmdResultCode;
X    }
X
XexitPoint:
X    if (savedResult != NULL)
X        ckfree (savedResult);
X    /*
X     * An error might have caused clearing of some signal flags to be missed.
X     */
X    Tcl_ResetSignals ();
X    return result;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * ParseSignalList --
X *
X *   Parse a list of signal names or numbers.
X *
X * Parameters:
X *   o interp (O) - Interpreter for returning errors.
X *   o signalListStr (I) - The Tcl list of signals to convert.
X *   o signalList (O) - The list of converted signal numbers, must be
X *     big enough to hold MAXSIG signals.
X *     Tcl_Eval just completed.
X * Returns:
X *   The number of signals converted, or -1 if an error occures.
X *----------------------------------------------------------------------
X */
Xstatic int
XParseSignalList (interp, signalListStr, signalList)
X    Tcl_Interp *interp;
X    char       *signalListStr;
X    int         signalList [];
X{
X    char         **signalListArgv;
X    int            signalListSize, signalNum, idx;
X    int            result = -1;
X    char          *signalName;
X
X    if (Tcl_SplitList (interp, signalListStr, &signalListSize,
X                       &signalListArgv) != TCL_OK)
X        return -1;
X
X    if (signalListSize > MAXSIG) {
X        Tcl_AppendResult (interp, "too many signals supplied in list",
X                          (char *) NULL);
X        goto exitPoint;
X    }
X
X    if (signalListSize == 0) {
X        Tcl_AppendResult (interp, "signal list may not be empty",
X                          (char *) NULL);
X        goto exitPoint;
X    }
X
X    for (idx = 0; idx < signalListSize; idx++) {
X        signalName = signalListArgv [idx];
X
X        if (Tcl_StrToInt (signalName, 0, &signalNum))
X            signalName = Tcl_SignalId (signalNum);
X        else
X            signalNum = Tcl_SigNameToNum (signalName);
X
X        if (signalName == NULL) {
X            char numBuf [20];
X
X            sprintf (numBuf, "%d", signalNum);
X            Tcl_AppendResult (interp, "invalid signal number: ",
X                              numBuf, (char *) NULL);
X            goto exitPoint;
X        }
X
X        if ((signalNum < 1) || (signalNum > NSIG)) {
X            Tcl_AppendResult (interp, "invalid signal name: ",
X                              signalName, (char *) NULL);
X            goto exitPoint;
X        }
X        signalList [idx] = signalNum;
X    }
X
X    result = signalListSize;
XexitPoint:
X    ckfree ((char *) signalListArgv);
X    return result;
X
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_SignalCmd --
X *     Implements the TCL signal command:
X *         signal action siglist [command]
X *
X * Results:
X *      Standard TCL results, may return the UNIX system error message.
X *
X * Side effects:
X *
X *----------------------------------------------------------------------
X */
Xstatic int
XTcl_SignalCmd (clientData, interp, argc, argv)
X    char       *clientData;
X    Tcl_Interp *interp;
X    int         argc;
X    char      **argv;
X{
X    int            signalListSize, signalNum, idx;
X    int            signalList [MAXSIG];
X    char          *signalName;
X    SIG_PROC_TYPE  (*actionFunc)();
X    int            commandLen = -1;
X
X    if ((argc < 3) || (argc > 4)) {
X        Tcl_AppendResult (interp, "wrong # args: ", argv [0],
X                          " action signalList [commands]", (char *) NULL);
X        return TCL_ERROR;
X    }
X
X    signalListSize = ParseSignalList (interp, argv [2], signalList);
X    if (signalListSize < 0)
X        return TCL_ERROR;
X
X    /*
X     * Determine the action to take on all of the signals.
X     */
X    if (STREQU (argv [1], "trap")) {
X        actionFunc = TclSignalTrap;
X        if (argc != 4) {
X            Tcl_AppendResult (interp, argv[0], ": command required for ",
X                             "trapping signals", (char *) NULL);
X            return TCL_ERROR;
X        }
X        commandLen = strlen (argv [3]);
X    } else {
X        if (STREQU (argv [1], "default")) {
X            actionFunc = SIG_DFL;
X        } else if (STREQU (argv [1], "ignore")) {
X            actionFunc = SIG_IGN;
X        } else if (STREQU (argv [1], "error")) {
X            actionFunc = TclSignalTrap;
X        } else if (!STREQU (argv [1], "get")) {
X            Tcl_AppendResult (interp, "invalid signal action specified: ",
X                              argv [1], ": expected one of \"default\", ",
X                              "\"ignore\", \"error\", \"trap\", or \"get\"",
X                              (char *) NULL);
X            return TCL_ERROR;
X        }
X    }
X
X    /*
X     * Either get or set the signals.
X     */
X    if (argv [1][0] == 'g') {
X        char *actionList [MAXSIG];
X
X        for (idx = 0; idx < signalListSize; idx ++) {
X            signalNum = signalList [idx];
X
X            actionFunc = GetSignalState (signalNum);
X            if (actionFunc == SIG_ERR)
X                goto unixSigError;
X
X            if (actionFunc == SIG_DFL)
X                actionList [idx] = "default";
X            else if (actionFunc == SIG_IGN)
X                actionList [idx] = "ignore";
X            else if (actionFunc == TclSignalTrap) {
X                if (signalTrapCmds [signalNum] == NULL)
X                    actionList [idx] = "error";
X                else
X                    actionList [idx] = "trap";
X            }
X        }
X        Tcl_SetResult (interp, Tcl_Merge (signalListSize, actionList),
X                       TCL_DYNAMIC);
X    } else {
X        for (idx = 0; idx < signalListSize; idx ++) {
X            signalNum = signalList [idx];
X
X            if (signalTrapCmds [signalNum] != NULL) {
X                ckfree (signalTrapCmds [signalNum]);
X                signalTrapCmds [signalNum] = NULL;
X            }
X            if (!SetSignalAction (signalNum, actionFunc))
X                goto unixSigError;
X
X            if (commandLen > 0) {
X                signalTrapCmds [signalNum] = ckalloc (commandLen + 1);
X                strcpy (signalTrapCmds [signalNum], argv [3]);
X            }
X        }
X    }
X    return TCL_OK;
X
XunixSigError:
X    Tcl_AppendResult (interp, "error setting or getting signal: ",
X                      Tcl_UnixError (interp), (char *) NULL);
X    return TCL_ERROR;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X *  SignalCmdCleanUp --
X *      Clean up the signal table when the interpreter is deleted.  This
X *      is actually when the signal command is deleted.  It releases the
X *      all signal commands that have been allocated.
X *
X *----------------------------------------------------------------------
X */
Xstatic void
XSignalCmdCleanUp (clientData)
X    ClientData clientData;
X{
X    int idx;
X
X    for (idx = 0; idx < MAXSIG; idx++)
X        if (signalTrapCmds [idx] != NULL) {
X            ckfree (signalTrapCmds [idx]);
X            signalTrapCmds [idx] = NULL;
X        }
X
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_InitSignalHandling --
X *      Initializes the TCL unix commands.
X *
X * Side effects:
X *    A catch trap is armed for the SIGINT signal.
X *
X *----------------------------------------------------------------------
X */
Xvoid
XTcl_InitSignalHandling (interp)
X    Tcl_Interp *interp;
X{
X    int idx;
X
X    for (idx = 0; idx < MAXSIG; idx++) {
X        signalsRecieved [idx] = FALSE;
X        signalTrapCmds [idx] = NULL;
X    }
X    Tcl_CreateCommand (interp, "signal", Tcl_SignalCmd, (ClientData)NULL,
X                      SignalCmdCleanUp);
X    /*
X     * If interrupt is currently  being trapped, enabled it.  Other wise
X     * leave it off, or if this process is running as a background job it will
X     * get its parent's (shell's) signals.
X     */
X    if (GetSignalState (SIGINT) != SIG_IGN)
X        SetSignalAction (SIGINT, TclSignalTrap);
X}
X
END_OF_FILE
if test 20540 -ne `wc -c <'extended/src/signal.c'`; then
    echo shar: \"'extended/src/signal.c'\" unpacked with wrong size!
fi
# end of 'extended/src/signal.c'
fi
echo shar: End of archive 19 \(of 23\).
cp /dev/null ark19isdone
MISSING=""
for I in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 ; do
    if test ! -f ark${I}isdone ; then
    MISSING="${MISSING} ${I}"
    fi
done
if test "${MISSING}" = "" ; then
    echo You have unpacked all 23 archives.
    echo "Now cd to "extended", edit the makefile, then do a "make""
    rm -f ark[1-9]isdone ark[1-9][0-9]isdone
else
    echo You still need to unpack the following archives:
    echo "        " ${MISSING}
fi
##  End of shell archive.
exit 0

exit 0 # Just in case...
--
Kent Landfield                   INTERNET: [e-mail]
Sterling Software, IMD           UUCP:     uunet!sparky!kent
Phone:    [phone]         FAX:      [phone]
Please send comp.sources.misc-related mail to [e-mail].